home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The Original Shareware 1.1
/
The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso
/
19
/
madtrb11.zip
/
GRADES.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-01-02
|
47KB
|
1,928 lines
PROGRAM GRADES;
CONST
MAXRECORDS = 101;
MAXSIZE = 100; (*MAXSIZE := MAXRECORDS - 1*)
NAMESIZE = 20;
headsize = 50;
COMSIZE = 40;
TYPE
diskstring = string[2];
stringtype = string [NAMESIZE];
setofchar = set of char;
commandtype = string [COMSIZE];
gradeptr = ^gradetype;
gradetype = record
title : stringtype;
grade : real;
ptr : gradeptr;
end; (*gradetype*)
STUDENTTYPE = record
name : stringtype;
hmwk : gradeptr;
quiz : gradeptr;
test : gradeptr;
lab : gradeptr;
final : real;
ave : real;
fptr : integer;
bptr : integer;
end; (*classtype*)
STUDENTLIST = array [0 .. MAXSIZE] of STUDENTTYPE;
link = ^hashstructure;
hashstructure = record
pos : integer;
ptr : link;
end;
HASHTYPE = array [0 .. MAXSIZE] of link;
VAR
STUDENT : STUDENTLIST ;
HASH : HASHTYPE;
EMPTY,p,y : INTEGER;
header : string[headsize];
drive : diskstring;
file_out : boolean;
f : TEXT;
name : stringtype;
okset,nameset : setofchar;
beep : char;
(******************************** INITIALIZE *******************************)
PROCEDURE INITIALIZE;
var
i,j : integer;
begin
for i := 0 TO MAXSIZE do begin
with STUDENT [i] do begin
name := '[';
hmwk := nil;
quiz := nil;
test := nil;
lab := nil;
final := 0;
fptr := i+1;
bptr := 0;
end; (*with*)
hash [i] := nil;
end; (* for i *)
STUDENT [MAXSIZE].fptr := 0;
STUDENT [0].fptr := 0;
STUDENT [0].name := 'total pts: ';
EMPTY := 1;
end; (*initialize*)
{--------------------------------------}
procedure video (i : integer);
begin
textcolor (i);
end; { video }
{--------------------------------------}
function getchar (okset : setofchar):char;
var
c : char;
begin
read (kbd,c);
c := UpCase (c);
if not (c in okset) then write (beep)
else if c in [' '..'}'] then write (c);
while not (c in okset) do begin
read (kbd,c);
c := UpCase (c);
if not (c in okset) then write (beep)
else if (c in [' '..'}']) then write (c);
end; { while not good }
getchar := c;
end; { getchar }
{--------------------------------------}
procedure getname (var s : stringtype; okset : setofchar);
var
i : integer;
s1 : string[1];
stemp : stringtype;
begin
s1 := ' ';
stemp := '';
s1[1] := getchar (okset + [#13]);
if s1[1] in okset then stemp := concat (stemp,s1);
while (s1[1]<>#13) and (length(stemp)<NAMESIZE) do begin
if length(stemp)=0 then s1[1] := getchar (okset + [#13])
else if length(stemp)=NAMESIZE then s1[1] := getchar ([#13,#8])
else s1[1] := getchar (okset + [#13,#8]);
if s1[1] in okset then stemp := concat (stemp,s1)
else if s1[1]=#8 then begin
write (chr(8),' ',chr(8));
delete (stemp,length(stemp),1);
end { else }
end; { while }
if length(stemp)>0 then begin
s := stemp;
for i := (length(stemp)+1) to NAMESIZE do s := concat(s,'.');
end
else write (s);
end;
{--------------------------------------}
procedure getpaper (var s : stringtype; okset : setofchar);
var
i : integer;
s1 : string[1];
stemp : stringtype;
begin
s1 := ' ';
stemp := '';
s1[1] := getchar (okset + [#13]);
if s1[1] in okset then stemp := concat (stemp,s1);
while (s1[1]<>#13) and (length(stemp) < NAMESIZE) do begin
if length(stemp)=0 then s1[1] := getchar (okset + [#13])
else if length(stemp)=NAMESIZE then s1[1] := getchar ([#13,#8])
else s1[1] := getchar (okset + [#13,#8]);
if s1[1] in okset then stemp := concat (stemp,s1)
else if s1[1]=#8 then begin
write (chr(8),' ',chr(8));
delete (stemp,length(stemp),1);
end { else }
end; { while }
if length(stemp)>0 then begin
s := stemp;
for i := (length(stemp)+1) to NAMESIZE do s := concat(' ',s);
end
else write (s);
end;
{--------------------------------------}
procedure getstring (var s : stringtype; okset : setofchar);
var
i : integer;
s1 : string[1];
stemp : stringtype;
begin
s1 := ' ';
stemp := '';
s1[1] := getchar (okset + [#13]);
if s1[1] in okset then stemp := concat (stemp,s1);
while s1[1]<>#13 do begin
if length(stemp)=0 then s1[1] := getchar (okset + [#13])
else if length(stemp)=80 then s1[1] := getchar ([#13,#8])
else s1[1] := getchar (okset + [#13,#8]);
if s1[1] in okset then stemp := concat (stemp,s1)
else if s1[1]=#8 then begin
write (chr(8),' ',chr(8));
delete (stemp,length(stemp),1);
end { else }
end; { while }
if length(stemp)>0 then s := stemp
else write (s);
end;
{--------------------------------------}
procedure getint (com : commandtype; var int : integer);
var
s : stringtype;
i,result : integer;
begin
okset := (['-'] + ['0'..'9']);
repeat
write (com);
s := ''; result := 0;
getstring (s,okset);
if length(s)>0 then begin
val (s,i,result);
if result<>0 then begin video (30);
write (beep,' integer expected '); delay (2000); video (15);
delLine; clreol;
end; { if result <>0 }
end; {if length (s) >0 }
until result=0;
if length(s)>0 then int := i
else write (int);
end; { getint }
{--------------------------------------}
procedure getreal (com : commandtype; var rl : real);
var
r : real;
result : integer;
s : stringtype;
begin
okset := (['-','.'] + ['0'..'9']);
repeat
write (com);
s := ''; result := 0;
getstring (s,okset);
if length(s)>0 then begin
val (s,r,result);
if result<>0 then begin video (30);
write (beep,' real expected '); delay (2000); video (15);
delLine; clreol;
end; { if result <>0 }
end; { if length(s) >0 }
until result=0;
if length(s)>0 then rl := r
else write (rl);
end; { getreal }
{--------------------------------------}
function yes : boolean;
var
c : char;
begin
c := getchar (['Y','N']);
if c='Y' then yes := true
else yes := false;
end; { yes }
(********************************* COMPARE *********************************)
(* COMPARE =
-1 if term1 < term2
0 if term1 = term2
1 if term1 > term2
*)
FUNCTION COMPARE (term1,term2 : stringtype):integer;
begin
if (term1 > term2) then compare := 1
else if (term1 < term2) then compare := -1
else compare := 0;
end; (* compare*)
(******************************* HASHID ************************************)
FUNCTION HASHNAME (term : stringtype):integer;
var
i,key : integer;
begin
key := 0;
for i := 1 to length(term) do key := key + ord (term[i]);
HASHNAME := trunc (MAXRECORDS * (key * 0.618034 - trunc (key*0.618034)));
end; (*hash*)
(****************************** INSERTHASH *********************************)
PROCEDURE INSERTHASH (i : integer);
var
j : integer;
p : link;
begin
j := HASHNAME (STUDENT [i].name);
new (p);
p^.pos := i;
p^.ptr := HASH [j];
HASH [j] := p;
end; (* INSERTHASH *)
(******************************** INSERT ***********************************)
PROCEDURE INSERT (i : integer);
var
j : integer;
begin
j := STUDENT [0].fptr;
while (COMPARE (STUDENT [j].name,STUDENT [i].name) <1) do
if (COMPARE (STUDENT [j].name,STUDENT [i].name) =0) then begin
writeln; video (30);
writeln (beep,'Student already entered');
writeln ('Addition of name aborted');
video (15); delay (2000);
exit;
end
else
j := STUDENT [j].fptr;
EMPTY := STUDENT [i].fptr;
STUDENT [i].bptr := STUDENT [j].bptr;
STUDENT [i].fptr := STUDENT [STUDENT [j].bptr].fptr;
STUDENT [STUDENT [j].bptr].fptr := i;
STUDENT [j].bptr := i;
INSERTHASH (i);
end; (* insert *)
(****************************** ADDNAME ************************************)
PROCEDURE ADDNAME;
var
i : integer;
begin
clrscr;
i := EMPTY;
if i=0 then begin
writeln; video (30);
writeln (beep,'Maximum number of students already entered');
writeln ('Check manual for directions');
video(15); delay(2000);
end
else with STUDENT [i] do begin
writeln;
write ('Enter student name: ');
name := '';
getname (name,nameset);
if (length(name)>0) then insert (i)
else name := '[';
end; (*else*)
end; (*addname*)
(********************************* ENTERCLASS ****************************)
PROCEDURE ENTERCLASS;
var
i,num : integer;
begin
clrscr;
num := 0;
getint ('Number of students to be entered: ',num);
for i := 1 to num do
ADDNAME;
end; (* enterclass *)
(******************************* FINDNAME *******************************)
PROCEDURE FINDNAME (term : stringtype;
var found : boolean;
var p,q : link;
var j : integer);
begin
j := HASHNAME (term);
found := false;
q := nil;
p := HASH [j];
while (p<>nil) and not found do
if (COMPARE (STUDENT [p^.pos].name,term) = 0) then
found := true
else begin
q := p;
p := p^.ptr;
end; (*else*)
end; (* findname *)
(********************************* CHANGENAME ***************************)
PROCEDURE CHANGENAME;
var
term : stringtype;
i,j : integer;
found: boolean;
p,q : link;
begin
clrscr;
write ('Change which name? ');
term := '';
getName (term,nameset);
FindName (term,found,p,q,i);
if not found then begin
video (30); writeln;
writeln (beep,term,' not found in class list');
video(15); delay (2000);
end
else begin
j := p^.pos;
if q=nil then
HASH [i] := p^.ptr
else
q^.ptr := p^.ptr;
writeln; writeln;
write ('Change name to? ');
getname (STUDENT [j].name,nameset);
i := STUDENT [0].fptr;
while (COMPARE (STUDENT [i].name,STUDENT [j].name)<1) and (i<>0) do
i := STUDENT [i].fptr;
STUDENT [STUDENT [j].bptr].fptr := STUDENT [j].fptr;
STUDENT [STUDENT [j].fptr].bptr := STUDENT [j].bptr;
STUDENT [j].bptr := STUDENT [i].bptr;
STUDENT [j].fptr := STUDENT [STUDENT [i].bptr].fptr;
STUDENT [STUDENT [i].bptr].fptr := j;
STUDENT [i].bptr := j;
INSERTHASH (j);
end; (* else *)
end; (* changename *)
(********************************** DELNAME *****************************)
PROCEDURE DELNAME;
var
i,j : integer;
found : boolean;
term : stringtype;
p,q : link;
begin
clrscr;
write ('Delete which student? ');
term := '';
getname (term,nameset);
FINDNAME (term,found, p,q,j);
if not found then begin
writeln; video (30);
writeln (beep,term,' not in classlist - no deletion performed!');
delay (2000); video (15);
end (* if *)
else begin
if q=nil then
HASH [j] := nil
else
q^.ptr := p^.ptr;
i := p^.pos;
STUDENT [STUDENT [i].bptr].fptr := STUDENT [i].fptr;
STUDENT [STUDENT [i].fptr].bptr := STUDENT [i].bptr;
STUDENT [i].fptr := EMPTY;
STUDENT [i].name := '[';
dispose (p);
EMPTY := i;
end; (* else *)
end; (* DELNAME *)
(*********************************** FindPaper **************************)
PROCEDURE FindPaper (var p,q : gradeptr;
j : stringtype;
var found : boolean);
begin
found := false;
q := nil;
while (p<>nil) and not found do
if (COMPARE (p^.title,j) <> 0) then begin
q := p;
p := p^.ptr;
end
else found := true;
end; (* findpaper *)
(********************************** InsertGrade **************************)
PROCEDURE InsertGrade (var p,q,s : gradeptr;
i,l : integer;
j : stringtype);
(* input parameters -
p - pointer from FindPaper
i - array position of student
j - title of paper*)
var
g : real;
found : boolean;
begin
with STUDENT [i] do begin
FindPaper (p,q,j,found);
g := p^.grade;
if l=1 then writeln (name,' ',g:4:1);
getreal (concat(name,' '),g);
if found then begin
s := p;
if (p^.grade=0) or (g>0) then
p^.grade := g
end
else begin
new (s);
s^.title := j;
s^.grade := g;
s^.ptr := p;
end; (* else *)
end; (* with *)
end; (* InsertGrade *)
(*********************************** SETGRADE **************************)
PROCEDURE SETGRADE (i,l : integer;
j : stringtype;
var r : gradeptr);
var
p,q,s : gradeptr;
begin
with STUDENT [i] do begin
p := r;
InsertGrade (p,q,s,i,l,j);
if q=nil then
r := s
else
q^.ptr := s;
end; (* with *)
end; (* setgrade *)
(****************************** GRADEMENU ********************************)
FUNCTION GRADEMENU:char;
begin
clrscr;
writeln ('Select type of paper from list');
writeln;
writeln (' H -- homework');
writeln (' Q -- quiz');
writeln (' L -- lab');
writeln (' E -- hour exam');
writeln (' F -- final exam');
writeln ('<cr>-- return to main menu');
writeln;
write ('Enter selection: ');
GRADEMENU := getchar (['H','Q','L','E','F',#13]);
end; (*grademenu*)
(********************************* ENTERGRADE ***************************)
PROCEDURE ENTERGRADE (i : integer; k : char;
j : stringtype;
l : integer);
begin
with STUDENT [i] do
case k of
'H' : SETGRADE (i,l,j,hmwk);
'Q' : SETGRADE (i,l,j,quiz);
'L' : SETGRADE (i,l,j,lab);
'E' : SETGRADE (i,l,j,test);
'F' : begin
writeln;
final := 0;
getreal (concat(name,' '),final);
end;
end; (*case*)
end; (* entergrade *)
(********************************** GetGrade ****************************)
FUNCTION GetGrade (i : integer; k : char;
j : stringtype):real;
var
p,q : gradeptr;
found : boolean;
begin
with STUDENT [i] do
case k of
'H' : begin
p := hmwk;
FindPaper (p,q,j,found);
if not found then
GetGrade := -1
else
GetGrade := p^.grade;
end;
'Q' : begin
p := quiz;
FindPaper (p,q,j,found);
if not found then
GetGrade := -1
else
GetGrade := p^.grade;
end;
'L' : begin
p := lab;
FindPaper (p,q,j,found);
if not found then
GetGrade := -1
else
GetGrade := p^.grade;
end;
'E' : begin
p := test;
FindPaper (p,q,j,found);
if not found then
GetGrade := -1
else
GetGrade := p^.grade;
end;
'F' : GetGrade := final;
end; (* case *)
end; (* GetGrade *)
(******************************** PUTINCLASS ******************************)
PROCEDURE PUTINCLASS;
var
i,t : integer;
j : stringtype;
c : char;
begin
c := GRADEMENU;
clrscr;
if c<>#13 then begin
if c<>'F' then begin
write ('Title of paper: '); j := '';
getpaper (j,nameset+['0'..'9']); writeln;
end (* if *)
else j := 'Final Exam';
t := trunc (GetGrade (0,c,j));
if (t<=0) then
repeat
ENTERGRADE (0,c,j,0);
t := trunc (GetGrade (0,c,j));
if t=0 then
writeln ('Total cannot be zero -- try again');
until (t>0)
else with STUDENT [0] do
writeln (name,t);
i := STUDENT [0].fptr;
repeat
writeln;
ENTERGRADE (i,c,j,0);
i := STUDENT [i].fptr;
until i=0;
end; (* if *)
end; (* putinclass *)
(********************************** ENTERPERSON ****************************)
PROCEDURE ENTERPERSON;
var
i,t : integer;
x,z : link;
found : boolean;
j,term : stringtype;
c : char;
begin
clrscr;
write ('Which student? '); term := '';
getname (term,nameset);
FindName (term,found,x,z,i);
if not found then begin
writeln; video(30);
writeln (beep,'Student not found'); video(15); delay(2000);
end (* if *)
else begin
i := x^.pos;
c := GRADEMENU;
clrscr;
if c<>#13 then begin
if c<>'F' then begin
write ('Title of paper: '); j := '';
getpaper (j,(nameset + ['0'..'9']));
end; (* if *)
t := trunc (GetGrade (0,c,j));
if t=-1 then begin
video(30); writeln;
writeln ('Paper not in file ');
video(15); delay(2000);
end
else
writeln;
ENTERGRADE (i,c,j,1);
end; (* if *)
end; (* else *)
end; (* enterperson *)
(********************************* REMOVE ********************************)
PROCEDURE REMOVE;
var
p,q : gradeptr;
i : integer;
term : stringtype;
found : boolean;
c : char;
begin
c := GRADEMENU;
clrscr;
write ('Remove which paper? ');
getpaper (term,nameset);
i := 0;
repeat
with STUDENT [i] do begin
case c of
'H': begin
p := hmwk;
FindPaper (p,q,term,found);
if found then begin
if q=nil then
hmwk := p^.ptr
else
q^.ptr := p^.ptr;
dispose (p);
end;
end;
'Q': begin
p := quiz;
FindPaper (p,q,term,found);
if found then begin
if q=nil then
quiz := p^.ptr
else
q^.ptr := p^.ptr;
dispose(p);
end;
end;
'L': begin
p := lab;
FindPaper (p,q,term,found);
if found then begin
if q=nil then
lab := p^.ptr
else
q^.ptr := p^.ptr;
dispose (p);
end;
end;
'E': begin
p := test;
FindPaper (p,q,term,found);
if found then begin
if q=nil then
test := p^.ptr
else
q^.ptr := p^.ptr;
dispose (p);
end;
end;
end; (* case *)
i := fptr;
end; (* with *)
until (i=0);
if not found then begin
writeln; video(30);
writeln (beep,term,' not found');
delay (2000); video(15);
end; (* if *)
end; (* remove *)
(********************************** WHO **********************************)
PROCEDURE WHO;
var
c : char;
begin
clrscr;
writeln ('Do you wish to:');
writeln;
writeln (' C -- Enter entire class');
writeln (' I -- Change individual grade');
writeln (' R -- Remove paper');
writeln ('<cr>-- Return to main menu');
writeln;
write ('Enter choice: ');
c := getchar (['C','I','R',#13]);
case c of
'C' : PUTINCLASS;
'I' : ENTERPERSON;
'R' : REMOVE;
end; (*case*)
end; (*who*)
(********************************* PRINTGRADES ****************************)
PROCEDURE PRINTGRADES (i : integer; var p,q : gradeptr; one : boolean);
var
a,t : real;
begin
a := 0;
t := 0;
if q = nil then
t := 1;
while (q<>nil) do begin
t := q^.grade + t;
q := q^.ptr;
end;
with STUDENT [i] do
write (f,name:20);
while (p<>nil) do begin
if one then begin
writeln(f);
write (f,p^.title);
end; (* if *)
a := a + p^.grade;
write (f,p^.grade:5:1);
p := p^.ptr;
if p=nil then
writeln (f,' ave : ',(a*100/t):5:1);
end; (* while *)
end; (* printgrades *)
(********************************* PRINTSTUDENT ****************************)
PROCEDURE PRINTSTUDENT (i : integer; c : char; one : boolean);
var
p,q : gradeptr;
begin
with STUDENT [i] do begin
case c of
'H': begin
p := hmwk;
q := STUDENT [0].hmwk;
PRINTGRADES (i,p,q,one);
end;
'Q' : begin
p := quiz;
q := STUDENT [0].quiz;
PRINTGRADES (i,p,q,one);
end;
'L' : begin
p := lab;
q := STUDENT [0].lab;
PRINTGRADES (i,p,q,one);
end;
'E' : begin
q := STUDENT [0].test;
p := test;
PRINTGRADES (i,p,q,one);
end;
'F' : writeln (f,name,(100*final/STUDENT [0].final):5:1);
end; (* case *)
end; (* with *)
end; (* printstudent *)
(********************************** TITLES *********************************)
PROCEDURE TITLES (q : gradeptr);
var
p : gradeptr;
i : integer;
begin
for i := 1 to NAMESIZE do begin
write (f,' ');
p := q;
while p<>nil do begin
write (f,' ',p^.title [i]);
p := p^.ptr;
end; (* while *)
writeln(f);
end; (* for *)
writeln(f);
with STUDENT [0] do begin
write (f,name:20);
p := q;
while p<>nil do begin
write (f,p^.grade:5:1);
p := p^.ptr;
end; (* while *)
end; (* with *)
writeln (f);
writeln (f,'-------------------------------------------------------------------------');
end; (* titles *)
(********************************* PRINTCLASS *****************************)
PROCEDURE PRINTCLASS;
var
i : integer;
c : char;
begin
c := GRADEMENU;
clrscr;
if c<>#13 then begin
case c of
'H' : TITLES (STUDENT [0].hmwk);
'Q' : TITLES (STUDENT [0].quiz);
'L' : TITLES (STUDENT [0].lab);
'E' : TITLES (STUDENT [0].test);
end; (* case *)
i := STUDENT [0].fptr;
repeat
with STUDENT [i] do begin
PRINTSTUDENT (i,c,false);
i := fptr;
if (i mod(15) = 0) then begin
writeln; write ('To continue press return'); readln;
y := wherey-2; gotoxy (1,y);
end;
end; (* with *)
until (i=0);
end; (* if *)
end; (* printclass *)
(******************************** PRINTPERSON ***************************)
PROCEDURE PRINTPERSON;
var
i : integer;
p : gradeptr;
x,z : link;
found : boolean;
term : stringtype;
c : char;
begin
clrscr;
write ('Which student? ');
term := '';
getname (term,nameset);
FindName (term,found,x,z,i);
if not found then begin
video (30); writeln;
writeln (beep,term,' not in class list');
video (15); writeln;
end
else begin
i := x^.pos;
c := GRADEMENU;
if c<>#13 then begin
clrscr;
PRINTSTUDENT (i,c,true);
end; (* if *)
end; (* else *)
writeln; write ('To continue press return'); readln;
end; (* printperson *)
(********************************* EXAMINE *******************************)
PROCEDURE EXAMINE;
var
j : integer;
p : gradeptr;
c : char;
procedure title;
begin
with STUDENT [j] do
while p<>nil do begin
writeln (f,p^.title,'--------',p^.grade:5:1);
p := p^.ptr;
end; (* while *)
end; (* title *)
begin
clrscr;
writeln ('Do you wish to see:');
writeln;
writeln (' N -- student names');
writeln (' H -- homework titles');
writeln (' Q -- quiz titles');
writeln (' L -- lab titles');
writeln ('<cr>-- return to main menu');
writeln;
write ('Enter choice: ');
c := getchar (['N','H','Q','L',#13]);
clrscr;
j := 0;
case c of
'N' : begin
writeln (f,'STUDENT':10);
j := STUDENT [0].fptr;
repeat
writeln (f,STUDENT [j].name);
j := STUDENT [j].fptr;
until (j=0);
end;
'H' : begin
writeln (f,'HOMEWORK TITLES TOTAL POINTS');
p := STUDENT [j].hmwk;
title;
end;
'Q' : begin
writeln (f,'QUIZ TITLES TOTAL POINTS');
p := STUDENT [j].quiz;
title;
end;
'L' : begin
writeln (f,'LAB TITLES TOTAL POINTS');
p := STUDENT [j].lab;
title;
end;
end; (* case *)
writeln; write ('To continue press return'); readln;
end; (* examine *)
{--------------------------------------}
{
Source: "TIMESTAMP and KBIN for the IBM-PC", TUG Lines Volume I Issue 2
Author: Karl Gerhard
Date: 7/5/84
Application: PC-DOS, MS-DOS
}
type
stdstr = string[80];
RecPack = record
AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAG:integer;
end;
var
regs:RecPack;
ch:char;
{------------------------}
function StrInt(n:integer):stdstr;
{ return a string with the integer in ASCII }
var s:string[6];
begin
str(n,s);
strint := s;
end;
{------------------------}
procedure CallDos(fcn:integer);
{ execute DOS fcn# call }
begin
with regs do begin
ax := fcn;
MsDos(regs);
end; { with }
end;
{------------------------}
function timestamp:stdstr;
{ return string of "MON DAY YEAR TIME" }
type mot = array[1..12] of string[3];
const mon:mot = ( 'JAN','FEB','MAR','APR','MAY','JUN',
'JUL','AUG','SEP','OCT','NOV','DEC');
var tsret:stdstr; hr:integer; ampm:string[2]; Min : string[2];
begin
CallDos($2A00);
with regs do begin
tsret := mon[Hi(DX)] +' '+ strint(Lo(DX)) +','+ strint(CX)+ ' ';
CallDos($2C00);
hr := Hi(cx);
if hr > 11 then ampm := 'pm'
else ampm := 'am';
if hr > 12 then hr := hr - 12;
min := strint (Lo(cx));
if length(min)=1 then min := concat('0',min);
timestamp := tsret + (strint(hr) ) + ':' + min + ampm;
end; { with }
end;
{-------------------------------------}
procedure Get_dir;
{ This program should display the disk directory from with any turbo program. }
type
dir_str = string[12];
regpack = record
ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
end; { recpack }
var
name1,name2 : dir_str;
found : boolean;
j : integer;
{-------------------------------------}
procedure Find_dta ( var dta_seg,dta_ofs : integer);
var
recpack : regpack;
begin
with recpack do begin
ax := $2F shl 8;
MsDos(recpack);
dta_seg := es;
dta_ofs := bx;
end; { with }
end; { Find_dta }
{-------------------------------------}
function get_filename : dir_str;
var
i,dta_seg,dta_ofs : integer;
result : dir_str;
c : char;
begin
Find_dta (dta_seg,dta_ofs);
result := '';
i := 30;
c := chr (mem[dta_seg:dta_ofs+i]);
while c<>chr(0) do begin
result := concat (result,c);
i := i + 1;
c := chr (mem[dta_seg:dta_ofs+i]);
end; { while }
get_filename := result;
end; { get_filename }
{-------------------------------------}
procedure dir_first ( source : dir_str;
var result : dir_str;
var found : boolean);
var
recpack : regpack;
flg : byte;
begin
source := concat (source,chr(0));
with recpack do begin
ax := $4E shl 8;
ds := (seg(source));
dx := (ofs(source) + 1);
end;
MsDos(recpack);
result := '';
flg := recpack.flags and 1;
if flg = 0 then begin
found := true;
result := get_filename;
end { if found }
else found := false;
end; { dir_first }
{-------------------------------------}
procedure dir_next ( source : dir_str;
var result : dir_str;
var found : boolean);
var
recpack : regpack;
flg : byte;
begin
source := concat (source,chr(0));
with recpack do begin
ax := $4F shl 8;
ds := (seg(source));
dx := (ofs(source)+1);
end; { with }
MsDos (recpack);
result := '';
flg := recpack.flags and 1;
if flg=0 then begin
found := true;
result := get_filename;
end
else found := false;
end;
{---------- MAIN PROGRAM -----------}
begin
clrscr; drive := '';
write ('Dir mask: '); drive[1] := getchar(['A','B','C','D']);
drive[2] := ':';
name1 := concat (concat(drive[1],drive[2]),'*.*');
dir_first (name1,name2,found); writeln; writeln;
if found then begin
write (name2:15);
j := 1;
repeat
j := j + 1;
dir_next (name1,name2,found);
if found then write (name2:15);
if j = 4 then begin writeln; j := 0; end;
until not found;
end;
window (1,18,80,25);
end; { procedure get_dir }
{--------------------------------------}
procedure rename (var name : stringtype);
var
c : char;
i,j : integer;
begin
clrscr;
i := length (name);
j := pos (':',name);
if j=0 then begin
if i>7 then delete (name,9,(i-8));
name := concat (concat(drive[1],drive[2]),name);
end { if no semicolon }
else if j<>2 then begin
delete (name,j,1);
if i>7 then delete (name,9,(i-8));
name := concat (drive,name);
end; { if semicolon wrong }
i := length (name);
j := pos('.',name);
if j=0 then
name := concat (name,'.dat')
else if j<>(i-3) then
delete (name,(j+4),i);
end; { rename }
(********************************** SAVE ******************************)
PROCEDURE SAVE;
var
v : integer;
ok,destroy: boolean;
i : integer;
procedure putfield (r : gradeptr);
var
p : gradeptr;
j : integer;
begin
p := r;
while p<>nil do begin
writeln (f,p^.title:20,' ',p^.grade);
p := p^.ptr;
end; (* while *)
writeln (f,' [':20,0:4);
end; (* putfield *)
begin
get_dir;
okset := ([':','_','.','\'] + ['A'..'Z'] + ['0'..'9']);
repeat
clrscr;
destroy := true;
write('Output filename : '); name := '';
getstring (name,okset);
if (length (name)=0) then begin
window (1,1,80,25); exit;
end;
rename (name);
assign(f,name);
{$i-} reset(f); {$i+}
ok := (ioresult=0);
if ok then begin
clrscr; delLine; video (30);
writeln (beep,name,' already exist on disk'); video (15);
writeln; write ('Do you wish to destroy file? (Y/N) ');
if not yes then destroy := false
else ok := false;
close (f);
end; { if file exist }
close (f);
until not ok;
if destroy then begin
video (30);
writeln; writeln ('Writing to disk');
rewrite (f);
writeln (f,EMPTY);
i := 0;
while (i<=MAXSIZE) and (STUDENT[i].name<>'[') do begin
with STUDENT[i] do begin
writeln (f,name:20,fptr:10,bptr:10);
putfield (hmwk);
putfield (quiz);
putfield (lab);
putfield (test);
writeln (f,final);
end; (* with *)
i := i + 1;
end; (* while *);
video (15);
close (f);
window (1,1,80,25);
end; (* if *)
end; (* save *)
(******************************* RETRIEVE ********************************)
PROCEDURE RETRIEVE;
var
i,j,k,l : integer;
ok : boolean;
c : char;
procedure getfield (var p : gradeptr);
var
s : gradeptr;
begin
p := nil;
new (s);
readln (f,s^.title,s^.grade);
while (s^.title[20] <> '[') and not eof(f) do begin
s^.ptr := p;
p := s;
new (s);
readln (f,s^.title,s^.grade);
end; (* while *)
end; (* getfield *)
begin
okset := ([':','_','.','\'] + ['A'..'Z'] + ['0'..'9']);
get_dir;
repeat
clrscr;
write('Input filename : '); name := '';
getstring (name,okset);
if (length(name)=0) then begin
window (1,1,80,25); exit;
end;
rename (name);
assign(f,name);
{$i-} reset(f); {$i+}
ok := (ioresult=0);
if not ok then begin
writeln; video (30);
writeln (beep,'ERROR --- ',name,' not on disk'); video(15);
ok := false; delay(2000);
end; { if file exist }
until ok;
clrscr; video (30);
writeln (' Please wait --- reading input file'); video (15);
for i := 0 to MAXSIZE do
HASH [i] := nil;
readln (f,EMPTY);
i := 0;
while not eof(f) do begin
with STUDENT [i] do begin
readln (f,name,fptr,bptr);
getfield (hmwk);
getfield (quiz);
getfield (lab);
getfield (test);
readln (f,final);
end; (* with *)
INSERTHASH (i);
i := i+1;
end; (* while *)
for i := EMPTY to MAXSIZE do with STUDENT[i] do begin
name := '['; fptr := i+1; bptr := 0; final := 0;
end; { for i }
STUDENT[i].fptr := 0;
close (f);
window (1,1,80,25);
end; (* RETRIEVE *)
{--------------------------------------}
procedure files;
var
v : integer;
ok,destroy: boolean;
i : integer;
begin
get_dir;
okset := ([':','_','.','\'] + ['A'..'Z'] + ['0'..'9']);
repeat
clrscr;
destroy := true;
write('Output filename : '); name := '';
getstring (name,okset);
if (length (name)=0) then begin
window (1,1,80,25); exit;
end;
rename (name);
assign(f,name);
{$i-} reset(f); {$i+}
ok := (ioresult=0);
if ok then begin
clrscr; delLine; video (30);
writeln (beep,name,' already exist on disk'); video (15);
writeln; write ('Do you wish to destroy file? (Y/N) ');
if not yes then destroy := false
else ok := false;
close (f);
end; { if file exist }
close (f);
until not ok;
if destroy then begin
video (30);
writeln; writeln ('Writing to disk');
rewrite (f);
file_out := true;
video (15);
window (1,1,80,25);
end;
end;
(*********************************** AVERAGE *****************************)
PROCEDURE AVERAGE;
var
i,j,num : integer;
yn : char;
ha,qa,la,ta : real;
wh,wq,wl,wt,wf : real;
th,tq,tl,tt,tf : real;
grades : array [0 .. 100] of integer;
function avegrade (i : integer;
r : gradeptr):real;
var
a : real;
p : gradeptr;
begin
a := 0;
p := r;
while p<>nil do
with STUDENT [i] do begin
a := a + p^.grade;
p := p^.ptr;
end; (* while *)
if a=0 then
a := 0.000001;
avegrade := a;
end;
begin
for i := 0 to 100 do
grades [i] := 0;
clrscr;
writeln ('Enter overall weights');
writeln; wh := 0;
getreal ('homework: ',wh);
wq := 0;
getreal (' quiz: ',wq);
wl := 0;
getreal (' lab: ',wl);
wt := 0;
getreal (' test: ',wt);
wf := 0;
getreal (' final: ',wf);
clrscr;
if not file_out then
writeln (f,' NAME HMWK QUIZ LAB TEST FINAL AVERAGE');
with STUDENT [0] do begin
th := avegrade (0,hmwk);
tq := avegrade (0,quiz);
tl := avegrade (0,lab);
tt := avegrade (0,test);
if final=0 then
tf := 1
else
tf := final;
i := fptr;
end; (* with *)
num := 0;
repeat
with STUDENT [i] do begin
ave := 0;
ha := avegrade (i,hmwk)*100/th;
qa := avegrade (i,quiz)*100/tq;
la := avegrade (i,lab)*100/tl;
ta := avegrade (i,test)*100/tt;
ave := (wh*ha + wq*qa + wl*la + wt*ta)/100 + wf*final/tf;
if (round(ave) in [0 .. 100]) then begin
num := num + 1;
grades [round (ave)] := grades [round (ave)] + 1;
end; (* if *)
writeln (f,name:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,(final*100/tf):7:1,ave:9:1);
i := fptr;
if not file_out then
if (i mod(15) = 0) then begin
writeln; write ('To continue press return'); readln;
y := wherey - 2; gotoxy (1,y);
end;
end; (* with *)
until (i=0);
if not file_out then begin
writeln (f); delline;
write ('Frequency plot? ');
if yes then begin
clrscr;
i := 100;
while (grades [i] = 0) and (i>0) do
i := i-1;
while (num>0) and (i>0) do begin
write (f,i,' ',chr(124),' ');
for j := 1 to grades [i] do
write (f,'*');
writeln (f);
num := num - grades [i];
i := i - 1;
end; (* while *)
writeln; write ('To continue press return'); readln;
end; (* if *)
end;
end; (* average *)
{------------------- get_print ---------------------}
procedure get_print;
var
c : char;
i,code : integer;
begin
clrscr;
writeln ('Select printer options');
writeln;
writeln ('TYPE STYLE');
writeln (' 1 - Pica');
writeln (' 2 - Elite');
writeln (' 3 - Compressed pica');
writeln (' 4 - Compressed elite');
writeln;
write ('Enter Choice --> '); c := getchar (['1','2','3','4']);
val(c,i,code);
writeln; writeln;
write ('Skip over margin? (Y/N) --> '); c := getchar (['Y','N']);
if c='Y' then begin p := 60; i := 4 + i; end else p := 66;
writeln; writeln; write ('Page header --> '); readln (header);
case i of
1 : write (lst,chr(18),chr(27),'P');
2 : write (lst,chr(18),chr(27),'M');
3 : write (lst,chr(15),chr(27),'P');
4 : write (lst,chr(15),chr(27),'M');
5 : write (lst,chr(27),'N',chr(6),chr(18),chr(27),'P');
6 : write (lst,chr(27),'N',chr(6),chr(18),chr(27),'M');
7 : write (lst,chr(27),'N',chr(6),chr(15),chr(27),'P');
8 : write (lst,chr(27),'N',chr(6),chr(15),chr(27),'M');
end;
for i := length(header) to headsize do header := concat(header,' ');
end;
(********************************* PRINT *********************************)
PROCEDURE PRINT;
var
i : char;
begin
clrscr;
file_out := false;
write ('(S) creen or (P) rinter or (F)ile? '); i := getchar (['S','P','F',#13]);
case i of
'S' : assign (f,'con:');
'P' : begin
assign (f,'lst:');
get_print;
writeln (f,' ',header:headsize,' ',timestamp);
end;
'F' : begin
files;
if length(name)=0 then exit;
average;
exit;
end;
#13 : exit;
end;
if not file_out then reset (f);
clrscr;
writeln ('Do you wish to see:');
writeln;
writeln (' T -- T(itles');
writeln (' C -- C(lass grades (one field)');
writeln (' I -- I(ndividual''s grade');
writeln (' A -- class (A)verages (all fields)');
writeln ('<cr>-- return to main menu');
writeln;
write ('Enter choice: ');
i := getchar (['A','T','C','I',#13]);
case i of
'T' : EXAMINE;
'C' : PRINTCLASS;
'I' : PRINTPERSON;
'A' : AVERAGE;
#13 : exit;
end; (* case *)
write (f,chr(12));
close (f);
end; (* print *)
(*********************************** NAME *******************************)
PROCEDURE NAMES;
var
c : char;
begin
clrscr;
writeln ('Select option:');
writeln;
writeln (' E -- enter names');
writeln (' C -- change name');
writeln (' D -- delete name');
writeln ('<cr>-- return to main menu');
writeln;
write ('Enter choice: ');
c := getchar (['E','C','D',#13]);
case c of
'E' : ENTERCLASS;
'C' : CHANGENAME;
'D' : DELNAME;
end; (* case *)
end; (* name *)
procedure get_file (v:stringtype);
var
i,j,k,l : integer;
ok : boolean;
c : char;
begin
okset := ([':','_','.','\'] + ['A'..'Z'] + ['0'..'9']);
get_dir;
repeat
clrscr;
write(v); name := '';
getstring (name,okset);
if (length(name)=0) then begin
window (1,1,80,25); exit;
end;
rename (name);
assign(f,name);
{$i-} reset(f); {$i+}
ok := (ioresult=0);
if not ok then begin
writeln; video (30);
writeln (beep,'ERROR --- ',name,' not on disk'); video(15);
ok := false; delay(2000);
end; { if file exist }
until ok;
close (f);
window (1,1,80,25);
end;
procedure merge;
var
i,num,j : integer;
f1,f2 : text;
line1,line2 : string[255];
eof1,eof2 : boolean;
grades : array [0 .. 100] of integer;
stuname,stuname2 : stringtype;
qa,la,ha,ta,final,ave : real;
q,l,h,t,fin,av : real;
begin
clrscr;
get_file ('File to merge --> ');
if length (name)=0 then exit;
assign (f1,name);
get_file ('File to merge --> ');
assign (f2,name);
files;
reset(f1); reset(f2); rewrite (f);
eof1 := false; eof2 := false;
if eof(f1) then eof1 := true;
if eof(f2) then eof2 := true;
if not eof1 then readln (f1,stuname,ha,qa,la,ta,final,ave);
if not eof2 then readln (f2,stuname2,h,q,l,t,fin,av);
while not eof1 and not eof2 do begin
if (stuname<=stuname2) then begin
writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
readln (f1,stuname,ha,qa,la,ta,final,ave);
if eof(f1) then eof1 := true;
end
else begin
writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
readln (f2,stuname2,h,q,l,t,fin,av);
if eof(f2) then eof2 := true;
end;
end; { while }
if eof2 then begin
while not eof1 do begin
if (stuname>stuname2) and eof2 then begin
eof2 := false;
writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
stuname2 := '{';
end
else begin
writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
readln (f1,stuname,ha,qa,la,ta,final,ave);
if eof(f1) then eof1 := true;
end
end; { while }
if (stuname2<>'{') then
if (stuname<=stuname2) then begin
writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
end
else begin
writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
end
else writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1)
end { if eof2 }
else begin
while not eof2 do begin
if (stuname<=stuname2) and eof1 then begin
eof1 := false;
writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
stuname := '{';
end
else begin
writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
readln (f2,stuname2,h,q,l,t,fin,av);
if eof(f2) then eof2 := true;
end
end;
if (stuname<>'{') then
if (stuname<=stuname2) then begin
writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
end
else begin
writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
end
else writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
end; { else not eof2 }
close (f); close (f1); close(f2);
clrscr;
write ('Send merged file to printer? ');
if yes then begin
for i := 1 to 100 do grades[i] := 0;
reset (f);
writeln (lst,' NAME HMWK QUIZ LAB TEST FINAL AVERAGE');
writeln (lst,'===========================================================');
num := 0;
repeat
readln (f,stuname,ha,qa,la,ta,final,ave);
writeln (lst,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
num := num + 1;
i := round(ave);
if (i<=100) and (i>0) then
grades [i] := grades[i]+1;
if num mod(60) = 0 then begin
write(lst,chr(12));
writeln (lst,' NAME HMWK QUIZ LAB TEST FINAL AVERAGE');
writeln (lst,'===========================================================');
end;
until eof(f);
writeln (lst);
writeln;writeln;
write ('Frequency plot? ');
if yes then begin
write (lst,chr(12));
i := 100;
while (grades [i] = 0) and (i>0) do
i := i-1;
while (num>0) and (i>0) do begin
write (lst,i,' ',chr(124),' ');
for j := 1 to grades [i] do
write (lst,'*');
writeln (lst);
num := num - grades [i];
i := i - 1;
end; (* while *)
end; { if }
end; (* if *)
close(f);
end; { merge }
(******************************* MENUDRIVE *******************************)
PROCEDURE MENUDRIVE (c : char);
begin
case c of
'N' : NAMES;
'P' : PRINT;
'G' : WHO;
'S' : SAVE;
'R' : RETRIEVE;
'M' : merge;
end; (* case *)
end; (* menudrive *)
(********************************** MENU *********************************)
PROCEDURE MENU;
var
i : integer;
c : char;
begin
repeat
clrscr;
writeln;
writeln ('GRADE MANAGEMENT SYSTEM *** Version 3.0 ***');
writeln;
writeln ('Memory available: ',MEMAVAIL,' PARAGRAPHS');
writeln;
writeln;
writeln ('Choose option from below: ');
writeln;
writeln (' N -- names');
writeln (' P -- print');
writeln (' G -- grades');
writeln (' S -- save file to disk');
writeln (' R -- retrieve file from disk');
writeln (' M -- merge files');
writeln (' L -- leave program');
writeln;
write ('Enter choice: ');
c := getchar (['N','P','R','S','G','L','M',#13]);
MENUDRIVE (c);
until c in (['L']);
end; (* menu *)
begin
textbackground (4);
video (15);
INITIALIZE;
beep := chr(7);
nameset := ['A'..'Z',' ',',','.'];
MENU;
end.